(in-package #:cl-fast-ecs/tests)


(define-test entities
  :parent cl-fast-ecs)

(define-test make-entity
  :parent entities
  (make-storage)
  (is = 0 (make-entity)))

(define-test delete-entity
  :parent entities
  (make-storage)
  (let ((entity (make-entity)))
    (finish
     (delete-entity entity))))

(define-test delete-entity-returns-nil
  :parent entities
  (make-storage)
  (let ((entity (make-entity)))
    (is eq nil (delete-entity entity))))

(define-test make-object
  :parent entities
  (make-storage)
  (let* ((x0 42.1)
         (y0 42.2)
         (object (make-object `((:coordinate :x ,x0 :y ,y0)))))
    (true (has-coordinate-p object))
    (with-coordinate () object
      (is = x0 x)
      (is = y0 y))))

(define-test make-object2
  :parent entities
  :depends-on (new-component-definition)
  (make-storage)
  (let* ((x0 42.1)
         (y0 42.2)
         (x1 0.1)
         (y1 0.2)
         (object (make-object `((:coordinate :x ,x0 :y ,y0)
                                (:velocity :x ,x1 :y ,y1)))))
    (true (has-coordinate-p object))
    (true (has-velocity-p object))
    (is = x0 (coordinate-x object))
    (is = y0 (coordinate-y object))
    (is = x1 (velocity-x object))
    (is = y1 (velocity-y object))))

(define-test "make-object called with nonexistent component"
  :parent entities
  (make-storage)
  (fail (make-object (list '(:nonexistent :x 0 :y 0))))
  (is = 0 (ecs::storage-entities-count *storage*)))

(define-test "make-object compiler macro"
  :parent entities
  (make-storage :initial-allocated 2)
  (with-mocks nil (if-called 'make-component
                             (lambda (i s e &key &allow-other-keys)
                               (declare (ignore i s e))
                               nil))
    (make-object '((:coordinate :x 0.0 :y 0.0)))
    (false (invocations 'make-component)))

  (fail (make-object '((:nonexistent :x 0 :y 0)))))

(define-test "entity-storage-hook is called"
  :parent entities
  (make-storage :initial-allocated 2)
  (let* ((hook-run-p nil)
         (hook (lambda (s) (declare (ignore s)) (setf hook-run-p t))))
    (hook-up *entity-storage-grown-hook* hook)
    (make-entity)
    (make-entity)
    (false hook-run-p)
    (make-entity)
    (true hook-run-p)))

(define-test entity-printer
  :parent entities
  :depends-on (empty-component)
  (make-storage)
  (let* ((x 42.1)
         (y 42.2)
         (name :test)
         (spec `((:coordinate :x ,x :y ,y :name ,name)
                 (:tag :name ,name)))
         (object (make-object spec)))
    (is equal spec (print-entity object (make-broadcast-stream)))
    (is string=
        (with-output-to-string (str) (prin1 spec str))
        (with-output-to-string (str) (print-entity object str)))))

(define-test entity-printer-skipping
  :parent entities
  :depends-on (empty-component)
  (make-storage)
  (let* ((x 42.1)
         (y 42.2)
         (name :test)
         (spec `((:coordinate :x ,x :y ,y :name ,name)
                 (:tag :name ,name)))
         (object (make-object spec)))
    (let ((*skip-printing-components* '(:coordinate)))
      (is equal
          `((:tag :name ,name))
          (print-entity object (make-broadcast-stream))))))

(define-test entities-picture-printer
  :parent entities
  :depends-on (empty-component)
  (make-storage)
  (uiop:with-temporary-file (:pathname picture
                             :type "png")
    (let* ((x 42.1)
           (y 42.2)
           (name :test)
           (spec `((:coordinate :x ,x :y ,y :name ,name)
                   (:tag :name ,name)))
           (object (make-object spec))
           (source (print-entities/picture
                    (list object) picture :keep-source t))
           (contents (alexandria:read-file-into-string source)))
      (true (probe-file picture))
      (true (search "\"COORDINATE\" -- \"TAG\"" contents))
      (true (search "\"0\"" contents))
      (true (search
             "\"COORDINATE-0\" [label=\"X = 42.1\\lY = 42.2\\lNAME = TEST\\l\"]"
             contents))
      (true (search "\"TAG-0\" [label=\"NAME = TEST\\l\"]" contents))
      (true (search
             "rank=same {\"0\" -- \"COORDINATE-0\" -- \"TAG-0\"}"
             contents))
      (true (search "\"COORDINATE\" -- \"COORDINATE-0\"" contents))
      (true (search "\"TAG\" -- \"TAG-0\"" contents)))))

(define-test entities-picture-printer-params
  :parent entities
  :depends-on (empty-component)
  (make-storage)
  (uiop:with-temporary-file (:pathname picture
                             :type "png")
    (let* ((x 42.1)
           (y 42.2)
           (name :test)
           (spec `((:coordinate :x ,x :y ,y :name ,name)
                   (:tag :name ,name)))
           (object (make-object spec))
           (source (print-entities/picture
                    (list object) picture :keep-source t
                    :bg-color :transparent
                    :name-getter (uiop:ensure-function :name)
                    :value-printer (uiop:ensure-function :val)))
           (contents (alexandria:read-file-into-string source)))
      (true (search "bgcolor=\"transparent\"" contents))
      (true (search "\"NAME\" [label=\"NAME\",shape=plaintext]" contents))
      (true (search
             "\"COORDINATE-NAME\" [label=\"X = VAL\\lY = VAL\\lNAME = VAL\\l\"]"
             contents))
      (true (search "\"TAG-NAME\" [label=\"NAME = VAL\\l\"]" contents))
      (true (search
             "rank=same {\"NAME\" -- \"COORDINATE-NAME\" -- \"TAG-NAME\"}"
             contents))
      (true (search "\"COORDINATE\" -- \"COORDINATE-NAME\"" contents))
      (true (search "\"TAG\" -- \"TAG-NAME\"" contents)))))

(define-test deletion-order
  :parent entities
  (make-storage)
  (dotimes (_ 5)
    (make-entity))
  (delete-entity 3)
  (delete-entity 1)
  (delete-entity 4)
  (delete-entity 0)
  (delete-entity 2)

  (is = 0 (make-entity))
  (is = 1 (make-entity))
  (is = 2 (make-entity))
  (is = 3 (make-entity))
  (is = 4 (make-entity))
  (is = 5 (make-entity)))

(define-test deletion-hook
  :parent entities
  (make-storage)
  (let* ((hook-run-p nil)
         (hook-fn (lambda (entity) (setf hook-run-p entity)))
         (entity (make-entity)))
    (hook-up ecs:*entity-deleting-hook* hook-fn)
    (delete-entity entity)
    (is = entity hook-run-p)
    (unhook ecs:*entity-deleting-hook* hook-fn)))

(define-test spec-adjoin
  :parent entities
  (is equal
      '((:component-a :x 1 :y 2) (:component-b :a 3 :b 4))
      (spec-adjoin '((:component-a :x 1 :y 2)
                     (:component-b :a 3 :b 4))
                   '(:component-a :x 1 :y 2)))
  (is equal
      '((:component-a :x 1 :y 2) (:component-b :a 3 :b 4))
      (spec-adjoin '((:component-a :x 1 :y 2)
                     (:component-b :a 3 :b 4))
                   '(:component-a :x 3 :y 4)))
  (is equal
      '((:component-c :foo 5 :bar 6)
        (:component-a :x 1 :y 2)
        (:component-b :a 3 :b 4))
      (spec-adjoin '((:component-a :x 1 :y 2)
                     (:component-b :a 3 :b 4))
                   '(:component-c :foo 5 :bar 6)))
  (is equal
      '((:component-a :x 1 :y 2))
      (spec-adjoin nil '(:component-a :x 1 :y 2)))
  (is equal
      '((:component-a :x 1 :y 2))
      (spec-adjoin '((:component-a :x 1 :y 2)) nil))
  (is equal nil (spec-adjoin nil nil)))

(define-test copy-entity
  :parent entities
  (make-storage)
  (let* ((spec '((:coordinate :x 0.0 :y 1.0 :name :||)))
         (entity (make-object spec))
         (entity1 (make-entity)))
    (is equal spec (print-entity (copy-entity entity)))
    (is = entity1 (copy-entity entity :destination entity1))
    (is equal spec (print-entity entity1))
    (is equal nil (print-entity (copy-entity entity :except '(:coordinate))))))

#+sbcl
(define-test make-object-optimized-for-quasiquote
  :parent entities
  (let ((disassembly (let ((*standard-output* (make-string-output-stream)))
                       (disassemble (lambda ()
                                      (make-object `((:coordinate :x ,(frob))))))
                       (get-output-stream-string *standard-output*))))
    (false (search "MAKE-OBJECT" disassembly))))

(define-test defentity
  :parent entities
  (setf *storage* nil)
  (with-fixtures '(ecs::*storage-initialized-hook*)
    (defentity test-entity `((:coordinate :x 1.0)))
    (false (entity-valid-p test-entity))
    (make-storage)
    (true (entity-valid-p test-entity))
    (is = 1.0 (coordinate-x test-entity))))

(define-test defentity-init-hook
  :parent entities
  (setf *storage* nil)
  (with-fixtures '(ecs::*storage-initialized-hook*)
    (defentity test-entity `((:coordinate :x 1.0)))
    (make-storage)
    (setf (coordinate-x test-entity) 2.0)
    (funcall (get 'test-entity 'init-global-entity))
    (is = 1.0 (coordinate-x test-entity))))
